home *** CD-ROM | disk | FTP | other *** search
/ TeX 1995 July / TeX CD-ROM July 1995 (Disc 1)(Walnut Creek)(1995).ISO / macros / latex209 / contrib / slatex / peephole.ss < prev    next >
Text File  |  1993-11-07  |  14KB  |  385 lines
  1. ;peephole.ss
  2. ;SLaTeX Version 1.99
  3. ;Peephole adjuster used by the SLaTeX typesetter
  4. ;(c) Dorai Sitaram, December 1991, Rice University
  5.  
  6. (define get-line
  7.   (let ((curr-notab &void-notab))
  8.     (lambda (line)
  9.       ;read the current tex line into "line";
  10.       ;returns false on eof
  11.       (let ((graphic-char-seen? #f))
  12.     (let loop ((i 0))
  13.       (let ((c (read-char *in*)))
  14.         (cond (graphic-char-seen? 'already-seen)
  15.           ((or (eof-object? c) 
  16.            (char=? c #\return) (char=? c #\newline)
  17.            (char=? c #\space) (char=? c #\tab))
  18.            'not-yet)
  19.           (else (set! graphic-char-seen? #t)))
  20.         (cond
  21.           ((eof-object? c)
  22.            (cond ((eq? curr-notab &mid-string)
  23.               (if (> i 0)
  24.             (setf (of line =notab / (- i 1)) &end-string)))
  25.              ((eq? curr-notab &mid-comment)
  26.               (set! curr-notab &void-notab))
  27.              ((eq? curr-notab &mid-math)
  28.               (lerror 'runaway-math-subformula)))
  29.            (setf (of line =char / i) #\newline)
  30.            (setf (of line =space / i) &void-space)
  31.            (setf (of line =tab / i) &void-tab)
  32.            (setf (of line =notab / i) &void-notab)
  33.            (setf (of line =rtedge) i)
  34.            (if (eq? (of line =notab / 0) &mid-string)
  35.          (setf (of line =notab / 0) &begin-string))
  36.            (if (= i 0) #f #t))
  37.           ((or (char=? c #\return) (char=? c #\newline))
  38.            (if (char=? c #\return)
  39.                 (if (char=? (peek-char *in*) #\newline) 
  40.                (read-char *in*)))
  41.            (cond ((eq? curr-notab &mid-string)
  42.               (if (> i 0)
  43.             (setf (of line =notab / (- i 1)) &end-string)))
  44.              ((eq? curr-notab &mid-comment)
  45.               (set! curr-notab &void-notab))
  46.              ((eq? curr-notab &mid-math)
  47.               (lerror 'runaway-math-subformula)))
  48.            (setf (of line =char / i) #\newline)
  49.            (setf (of line =space / i) &void-space)
  50.            (setf (of line =tab / i)
  51.          (cond ((eof-object? (peek-char *in*)) &plain-crg-ret)
  52.                (*intext?* &plain-crg-ret)
  53.                (else &tabbed-crg-ret)))
  54.            (setf (of line =notab / i) &void-notab)
  55.            (setf (of line =rtedge) i)
  56.            (if (eq? (of line =notab / 0) &mid-string)
  57.          (setf (of line =notab / 0) &begin-string))
  58.            #t)
  59.           ((eq? curr-notab &mid-comment)
  60.            (setf (of line =char / i) c)
  61.            (setf (of line =space / i)
  62.          (cond ((char=? c #\space) &plain-space)
  63.                ((char=? c #\tab) &plain-space)
  64.                (else &void-space)))
  65.            (setf (of line =tab / i) &void-tab)
  66.            (setf (of line =notab / i) &mid-comment)
  67.            (loop (+ i 1)))
  68.           ((char=? c #\\)
  69.            (setf (of line =char / i) c)
  70.            (setf (of line =space / i) &void-space)
  71.            (setf (of line =tab / i) &void-tab)
  72.            (setf (of line =notab / i) curr-notab)
  73.            (let ((i+1 (+ i 1)) (c+1 (read-char *in*)))
  74.          (if (char=? c+1 #\tab) (set! c+1 #\space))
  75.          (setf (of line =char / i+1) c+1)
  76.          (setf (of line =space / i+1)
  77.            (if (char=? c+1 #\space) &plain-space
  78.              &void-space))
  79.          (setf (of line =tab / i+1) &void-tab)
  80.          (setf (of line =notab / i+1) curr-notab)
  81.          (loop (+ i+1 1))))
  82.           ((eq? curr-notab &mid-math)
  83.            (if (char=? c #\tab) (set! c #\space))
  84.            (setf (of line =space / i)
  85.          (if (char=? c #\space) &plain-space
  86.            &void-space))
  87.            (setf (of line =tab / i) &void-tab)
  88.            (cond ((memv c *math-triggerers*)
  89.               (setf (of line =char / i) #\$)
  90.               (setf (of line =notab / i) &end-math)
  91.               (setf curr-notab &void-notab))
  92.              (else (setf (of line =char / i) c)
  93.                (setf (of line =notab / i) &mid-math)))
  94.            (loop (+ i 1)))
  95.           ((eq? curr-notab &mid-string)
  96.            (if (char=? c #\tab) (set! c #\space))
  97.            ;or should tab and space be treated differently?
  98.            (setf (of line =char / i) c)
  99.            (setf (of line =space / i)
  100.          (if (char=? c #\space) &inner-space &void-space))
  101.            (setf (of line =tab / i) &void-tab)
  102.            (setf (of line =notab / i)
  103.          (cond ((char=? c #\")
  104.             (set! curr-notab &void-notab)
  105.             &end-string)
  106.                (else &mid-string)))
  107.            (loop (+ i 1)))
  108.           ;henceforth curr-notab is &void-notab
  109.           ((char=? c #\space)
  110.            (setf (of line =char / i) c)
  111.            (setf (of line =space / i)
  112.          (cond (*intext?* &plain-space)
  113.                (graphic-char-seen? &inner-space)
  114.                (else &init-space)))
  115.            (setf (of line =tab / i) &void-tab)
  116.            (setf (of line =notab / i) &void-notab)
  117.            (loop (+ i 1)))
  118.           ((char=? c #\tab)
  119.            (let loop2 ((i i) (j 0))
  120.          (if (< j 8)
  121.                   (begin
  122.            (setf (of line =char / i) #\space)
  123.            (setf (of line =space / i)
  124.              (cond (*intext?* &plain-space)
  125.                (graphic-char-seen? &inner-space)
  126.                (else &init-space)))
  127.            (setf (of line =tab / i) &void-tab)
  128.            (setf (of line =notab / i) &void-notab)
  129.            (loop2 (+ i 1) (+ j 1)))))
  130.            (loop (+ i 8)))
  131.           ((char=? c #\")
  132.            (setf (of line =char / i) c)
  133.            (setf (of line =space / i) &void-space)
  134.            (setf (of line =tab / i) &void-tab)
  135.            (setf (of line =notab / i) &begin-string)
  136.            (set! curr-notab &mid-string)
  137.            (loop (+ i 1)))
  138.           ((char=? c #\;)
  139.            (setf (of line =char / i) c)
  140.            (setf (of line =space / i) &void-space)
  141.            (setf (of line =tab / i) &void-tab)
  142.            (setf (of line =notab / i) &begin-comment)
  143.            (set! curr-notab &mid-comment)
  144.            (loop (+ i 1)))
  145.           ((memv c *math-triggerers*)
  146.            (setf (of line =char / i) #\$)
  147.            (setf (of line =space / i) &void-space)
  148.            (setf (of line =tab / i) &void-tab)
  149.            (setf (of line =notab / i) &begin-math)
  150.            (set! curr-notab &mid-math)
  151.            (loop (+ i 1)))
  152.           (else (setf (of line =char / i) c)
  153.             (setf (of line =space / i) &void-space)
  154.             (setf (of line =tab / i) &void-tab)
  155.             (setf (of line =notab / i) &void-notab)
  156.             (loop (+ i 1))))))))))
  157.  
  158. (define peephole-adjust
  159.   (lambda (curr prev)
  160.     ;adjust the tabbing information on the current line curr and
  161.     ;its previous line prev relative to each other
  162.     (if (or (blank-line? curr) (flush-comment-line? curr))
  163.     (if *latex-paragraph-mode?* 'skip
  164.           (begin
  165.        (set! *latex-paragraph-mode?* #t)
  166.        (if *intext?* 'skip
  167.          (begin
  168.           (remove-some-tabs prev 0)
  169.           (let ((prev-rtedge (of prev =rtedge)))
  170.             (if (eq? (of prev =tab / prev-rtedge) &tabbed-crg-ret)
  171.             (setf (of prev =tab / (of prev =rtedge)) 
  172.               &plain-crg-ret)))))))
  173.     (begin
  174.       (if *latex-paragraph-mode?*
  175.           (set! *latex-paragraph-mode?* #f)
  176.           (if *intext?* 'skip
  177.         (let ((remove-tabs-from #f))
  178.           (let loop ((i 0))
  179.             (cond
  180.               ((char=? (of curr =char / i) #\newline)
  181.                (set! remove-tabs-from i))
  182.               ((char=? (of prev =char / i) #\newline)
  183.                (set! remove-tabs-from #f))
  184.               ((eq? (of curr =space / i) &init-space)
  185.                ;eating initial space of curr
  186.                (if (eq? (of prev =notab / i) &void-notab)
  187.             (begin
  188.              (cond
  189.                ((or (char=? (of prev =char / i) #\()
  190.                 (eq? (of prev =space / i) &paren-space))
  191.                 (setf (of curr =space / i) &paren-space))
  192.                ((or (char=? (of prev =char / i) #\[)
  193.                 (eq? (of prev =space / i) &bracket-space))
  194.                 (setf (of curr =space / i) &bracket-space))
  195.                ((or (memv (of prev =char / i) '(#\' #\` #\,))
  196.                 (eq? (of prev =space / i) "e-space))
  197.                 (setf (of curr =space / i) "e-space)))
  198.              (if (memq (of prev =tab / i)
  199.                      (list &set-tab &move-tab))
  200.                (setf (of curr =tab / i) &move-tab))))
  201.                (loop (+ i 1)))
  202.               ;finished tackling &init-spaces of curr
  203.               ((= i 0) ;curr starts left-flush
  204.                (set! remove-tabs-from 0))
  205.               ;at this stage, curr[notab,i]
  206.               ;is either #f or a &begin-comment/string
  207.               ((not (eq? (of prev =tab / i) &void-tab))
  208.                ;curr starts with nice alignment with prev
  209.                (set! remove-tabs-from (+ i 1))
  210.                (if (memq (of prev =tab / i) 
  211.                    (list &set-tab &move-tab))
  212.              (setf (of curr =tab / i) &move-tab)))
  213.               ((memq (of prev =space / i)
  214.                  (list &init-space &init-plain-space 
  215.                    &paren-space &bracket-space "e-space))
  216.                ;curr starts while prev is still empty
  217.                (set! remove-tabs-from (+ i 1)))
  218.               ((and (char=? (of prev =char / (- i 1)) #\space)
  219.                 (eq? (of prev =notab / (- i 1)) &void-notab))
  220.                ;curr can induce new alignment straightaway
  221.                (set! remove-tabs-from (+ i 1))
  222.                (setf (of prev =tab / i) &set-tab)
  223.                (setf (of curr =tab / i) &move-tab))
  224.               (else ;curr stakes its &move-tab (modulo parens/bkts)
  225.             ;and induces prev to have corresp &set-tab
  226.             (set! remove-tabs-from (+ i 1))
  227.             (let loop1 ((j (- i 1)))
  228.               (cond ((<= j 0) 'exit-loop1)
  229.                 ((not (eq? (of curr =tab / j) &void-tab))
  230.                  'exit-loop1)
  231.                 ((memq (of curr =space / j)
  232.                        (list &paren-space &bracket-space 
  233.                      "e-space))
  234.                  (loop1 (- j 1)))
  235.                 ((or (not (eq? (of prev =notab / j)
  236.                            &void-notab))
  237.                      (char=? (of prev =char / j) #\space))
  238.                  (let ((k (+ j 1)))
  239.                    (if (memq (of prev =notab / k)
  240.                          (list &mid-comment
  241.                            &mid-math &end-math
  242.                            &mid-string &end-string))
  243.                        'skip
  244.                         (begin
  245.                      (if (eq? (of prev =tab / k) &void-tab)
  246.                        (setf (of prev =tab / k) &set-tab))
  247.                      (setf (of curr =tab / k) &move-tab)))))
  248.                 (else 'anything-else?)
  249.                 )))))
  250.           (remove-some-tabs prev remove-tabs-from))))
  251.       (if *intext?* 'skip (add-some-tabs curr))
  252.       (clean-init-spaces curr)
  253.       (clean-inner-spaces curr)))))
  254.  
  255. (define add-some-tabs
  256.   (lambda (line)
  257.     ;add some tabs in the body of line "line" so the next line
  258.     ;can exploit them
  259.     (let loop ((i 1) (succ-parens? #f))
  260.       (let ((c (of line =char / i)))
  261.     (cond ((char=? c #\newline) 'exit-loop)
  262.           ((not (eq? (of line =notab / i) &void-notab))
  263.            (loop (+ i 1) #f))
  264.           ((char=? c #\[)
  265.            (if (eq? (of line =tab / i) &void-tab)
  266.          (setf (of line =tab / i) &set-tab))
  267.            (loop (+ i 1) #f))
  268.           ((char=? c #\()
  269.            (if (eq? (of line =tab / i) &void-tab)
  270.          (if succ-parens? 'skip
  271.            (setf (of line =tab / i) &set-tab)))
  272.            (loop (+ i 1) #t))
  273.           (else (loop (+ i 1) #f)))))))
  274.  
  275. (define remove-some-tabs
  276.   (lambda (line i)
  277.     ;remove useless tabs on line "line" after index i
  278.     (if i
  279.       (let loop ((i i))
  280.     (cond ((char=? (of line =char / i) #\newline) 'exit)
  281.           ((eq? (of line =tab / i) &set-tab)
  282.            (setf (of line =tab / i) &void-tab)
  283.            (loop (+ i 1)))
  284.           (else (loop (+ i 1))))))))
  285.  
  286. (define clean-init-spaces
  287.   (lambda (line)
  288.     ;remove init-spaces on line "line" because
  289.     ;tabs make them defunct
  290.     (let loop ((i (of line =rtedge)))
  291.       (cond ((< i 0) 'exit-loop)
  292.         ((eq? (of line =tab / i) &move-tab)
  293.          (let loop2 ((i (- i 1)))
  294.            (cond ((< i 0) 'exit-loop2)
  295.              ((memq (of line =space / i)
  296.                 (list &init-space &paren-space &bracket-space
  297.                   "e-space))
  298.               (setf (of line =space / i) &init-plain-space)
  299.               (loop2 (- i 1)))
  300.              (else (loop2 (- i 1))))))
  301.         (else (loop (- i 1)))))))
  302.  
  303. (define clean-inner-spaces
  304.   (lambda (line)
  305.     ;remove single inner spaces in line "line" since
  306.     ;paragraph mode takes care of them
  307.     (let loop ((i 0) (succ-inner-spaces? #f))
  308.       (cond ((char=? (of line =char / i) #\newline) 'exit-loop)
  309.         ((eq? (of line =space / i) &inner-space)
  310.          (if succ-inner-spaces? 'skip
  311.            (setf (of line =space / i) &plain-space))
  312.          (loop (+ i 1) #t))
  313.         (else (loop (+ i 1) #f))))))
  314.  
  315. (define blank-line?
  316.   (lambda (line)
  317.     ;check if line "line" is blank
  318.     (let loop ((i 0))
  319.       (let ((c (of line =char / i)))
  320.     (cond ((char=? c #\space) 
  321.            (if (eq? (of line =notab / i) &void-notab) 
  322.            (loop (+ i 1)) #f))
  323.           ((char=? c #\newline)
  324.            (let loop2 ((j (- i 1)))
  325.          (if (<= j 0) 'skip
  326.            (begin
  327.             (setf (of line =space / i) &void-space)
  328.             (loop2 (- j 1)))))
  329.            #t)
  330.           (else #f))))))
  331.  
  332. (define flush-comment-line?
  333.   (lambda (line)
  334.     ;check if line "line" is one with ; in the leftmost column
  335.     (and (char=? (of line =char / 0) #\;)
  336.      (eq? (of line =notab / 0) &begin-comment)
  337.      (not (char=? (of line =char / 1) #\;)))))
  338.  
  339. (define do-all-lines
  340.   (lambda ()
  341.     ;process all lines, adjusting each adjacent pair
  342.     (let loop ((line1 *line1*) (line2 *line2*))
  343.       (let* ((line2-paragraph? *latex-paragraph-mode?*)
  344.          (more? (get-line line1)))
  345.     ;
  346.     (peephole-adjust line1 line2)
  347.     ;
  348.     ((if line2-paragraph?
  349.          display-tex-line display-scm-line) line2)
  350.     ;
  351.     (if (eq? line2-paragraph? *latex-paragraph-mode?*) 'skip
  352.       ((if *latex-paragraph-mode?* display-end-sequence
  353.          display-begin-sequence) *out*))
  354.     ;
  355.     (if more? (loop line2 line1))))))
  356.  
  357. ;scheme2tex is the "interface" procedure supplied by this file --
  358. ;it takes Scheme code from inport and produces LaTeX source for same
  359. ;in outport
  360.  
  361. (define scheme2tex
  362.   (lambda (inport outport)
  363.     ;create a typeset version of scheme code from inport
  364.     ;in outport;
  365.     ;local setting of keywords, etc.?
  366.     (set! *in* inport)
  367.     (set! *out* outport)
  368.     (set! *latex-paragraph-mode?* #t)
  369.     (set! *in-qtd-tkn* #f)
  370.     (set! *in-bktd-qtd-exp* 0)
  371.     (set! *in-mac-tkn* #f)
  372.     (set! *in-bktd-mac-exp* 0)
  373.     (set! *case-stack* '())
  374.     (set! *bq-stack* '())
  375.     (let ((flush-line  ;needed anywhere else?
  376.         (lambda (line)
  377.           (setf (of line =rtedge) 0)
  378.           (setf (of line =char / 0) #\newline)
  379.           (setf (of line =space / 0) &void-space)
  380.           (setf (of line =tab / 0) &void-tab)
  381.           (setf (of line =notab / 0) &void-notab))))
  382.       (flush-line *line1*)
  383.       (flush-line *line2*))
  384.     (do-all-lines)))
  385.